home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TBUTIL1.LZH / UT-MOD01.INC < prev    next >
Text File  |  1984-08-30  |  4KB  |  148 lines
  1. procedure Msg(MsgString: str255; Col,Row: integer);
  2.    { Print a message at location Col,Row }
  3.  begin
  4.     gotoXY(Col,Row);  write(MsgString);
  5.  end;
  6.  
  7. procedure Center(S: str255; Col,Row,L: integer);
  8.   { Center a string on a line of L length beginning at position Col,Row }
  9.   {** (Col,Row) is row and column to center on **}
  10.   {** L is the length of the line to center on **}
  11. var I: integer;
  12.  begin
  13.     gotoXY(Col,Row);
  14.     for I:= 1 to L do write(' ');
  15.     gotoXY(Col+(L-Length(S)) div 2,Row); write(S);
  16.  end;
  17.  
  18. procedure InvVideo( InvStr: str255);
  19.     { print a string in inverse video }
  20.  begin
  21.    textBackground(15);textcolor(0); write(InvStr);
  22.    textBackground(0) ;textcolor(7);
  23.  end;
  24.  
  25. procedure Color(BackGnd,Txt: integer);
  26.    { change the background & text color }
  27.  begin
  28.    textBackGround(BackGnd); textColor(Txt);
  29.  end;
  30.  
  31. function UpcaseStr(S : Str80) : Str80;
  32.    { convert a string to UpperCase }
  33. var
  34.   P : Integer;
  35. begin
  36.   for P := 1 to Length(S) do
  37.     S[P] := Upcase(S[P]);
  38.   UpcaseStr := S;
  39. end;
  40.  
  41. function ConstStr(C : Char; N : Integer) : Str80;
  42.   (*  ConstStr returns a string with N characters of value C *)
  43. var
  44.   S : string[80];
  45. begin
  46.   if N < 0 then
  47.     N := 0;
  48.   S[0] := Chr(N);
  49.   FillChar(S[1],N,C);
  50.   ConstStr := S;
  51. end;
  52.  
  53. function fmt_real(num : real; len,dec: integer): str20;
  54.    { Sstring is string[20] }
  55.    { format a real number to length len (len is total length of string
  56.      including commas and decimal), with dec decimal places }
  57.  var  s1,s2,Temp : string[20];
  58.       C,I,J,K,Cd : integer;
  59.   begin
  60.     str(num,S1);
  61.     S1 := copy(S1,pos('+',S1)+1,2);
  62.     val(S1,C,cd); str(num:C:dec,S1);
  63.     S2 := copy(S1,pos('.',S1)+1,dec);
  64.     S1 := copy(S1,1,pos('.',S1)-1);
  65.     J:=1; K:=0;
  66.     for I := length(S1) downto 1 do
  67.       begin
  68.        if ((j mod 3) = 0) and (I <> 1) then
  69.          begin
  70.            if (I=2) and (copy(s1,1,1)='-') then S1:=S1 else
  71.            s1:=copy(s1,1,length(s1)-j-k)+','+copy(s1,i,length(s1)-i+1);
  72.            k:=k+1;
  73.          end;
  74.        J:=J+1;
  75.       end;
  76.     Temp := S1+'.'+S2;
  77.     if length(Temp) > len then Temp:='%'+Temp;
  78.     if length(Temp) < len then
  79.       begin
  80.        repeat Temp:=' '+Temp; until length(Temp)=len;
  81.       end;
  82.     Fmt_real := Temp;
  83.   end;
  84.  
  85. procedure Box(C1,R1,C2,R2,M: integer);
  86.  { Draw a box with a dividing line }
  87.  {* (C1,R1) is upper left of box, (C2,R2) is lower rt of box *}
  88.  {* M is the row of the dividing line (2nd line) of box      *}
  89.  var I,J,K: integer;
  90.   begin
  91.     K:= C2-C1-1; HighVideo;
  92.     GotoXY(C1,R1); write('┌');
  93.     for I:=1 to K do write('─');
  94.     write('┐');
  95.     for I:=R1+1 to R2-1 do
  96.     begin
  97.       GotoXY(C1,I); write('│');
  98.       if I = M then begin
  99.         for J:=1 to K do write('─');
  100.       end;
  101.       GotoXY(C2,I); write('│');
  102.     end;
  103.     GotoXY(C1,R2); write('└');
  104.     for I:=1 to K do write('─');
  105.     write('┘'); LowVideo;
  106.   end;
  107.  
  108. procedure Option;
  109.    { Read a keyboard character & convert to upper-case }
  110.  begin
  111.      read(kbd,Ch);  Ch:=UpCase(Ch);
  112.  end;
  113.  
  114. procedure StripSpaces(S: str255; var NewStr: str255);
  115.     {strip spaces from the end of a string}
  116.  begin
  117.    S:=S+'  '; NewStr := copy(S,1,pos('  ',S)-1);
  118.  end;
  119.  
  120. procedure ClrWnd(C1,R1,C2,R2: integer);
  121.    { Clear a selected portion of the screen }
  122.    {** (C1,R1) & (C2,R2) are upper left and lower rt of window **}
  123.  var I,J,K: integer;
  124.  begin
  125.    K:=C2-C1-1;
  126.    for I:=R1 to R2 do
  127.      begin
  128.        gotoXY(C1,I); for J:= 1 to K do write(' ');
  129.      end;
  130.  end;
  131.  
  132. procedure SaveScreen;
  133.     { save an image of the video in memory }
  134.  var mono: boolean;
  135.   begin
  136.     if (mem[0000:1040] and $30) = $30 then Mono:=true else Mono:=false;
  137.     if mono then move(video_scr1[1],memory_scr[1],4000)
  138.     else         move(video_scr2[1],memory_scr[1],4000);
  139.   end;
  140.  
  141. procedure FlashScreen;
  142.     { redisplay a memory image of a video display }
  143.  var mono: boolean;
  144.   begin
  145.     if (mem[0000:1040] and $30) = $30 then Mono:=true else Mono:=false;
  146.     if mono then move(memory_scr[1],video_scr1[1],4000)
  147.     else         move(memory_scr[1],video_scr2[1],4000);
  148.   end;